home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Especial Multimedia
/
Especial Multimedia.iso
/
Multimed
/
Fuentes
/
SYSFON.ZIP
/
SYSFON.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1997-09-14
|
16KB
|
463 lines
PROGRAM SysFon;
{ Version 1.0, 01/22/93 - written by Peter Karrer, pkarrer@bernina.ethz.ch }
{$M 16384,16384}
{$R SYSFON.RES}
{$I-}
USES WObjects, WinTypes, WinProcs, Strings, Win31, CommDlg;
CONST
appName: PCHAR = 'SysFon';
fntHdSize = 126;
fonHdSize = 356;
TYPE
FontDirEntry =
RECORD
version: WORD;
size: LONGINT;
copyright: ARRAY[0..59] OF CHAR;
typ, point, vRes, hRes, asc, iLead, eLead: WORD;
ita, usc, strike: byte;
weight: WORD;
charset: BYTE;
w, h: WORD;
pitchAndFam: BYTE;
avgW, maxW: WORD;
fCh, lCh, dCh, bCh: BYTE;
widthBytes: WORD;
dev, face, rsvd: LONGINT;
END;
HdrBufR = RECORD
constantStuff: ARRAY[0..$DF] OF BYTE;
fntSize: WORD;
otherStuff: ARRAY[0..48] OF BYTE;
moduleDescriptionLen: BYTE;
moduleDescription: ARRAY[0..73] OF CHAR;
trailer: ARRAY[0..31] OF CHAR;
END;
TThisApp = OBJECT(TApplication)
PROCEDURE InitMainWindow; VIRTUAL;
END;
PFnWin = ^TFnWin;
TFnWin = OBJECT(TDlgWindow)
dc: HDC;
fnH: HFont;
cf: TChooseFont;
lf: TLogFont;
tm: TTextMetric;
fd: FontDirEntry;
ofn: TOpenFileName;
faceName, orgFaceName: ARRAY[0..lf_FaceSize-1] OF CHAR;
CONSTRUCTOR Init;
PROCEDURE SetupWindow; VIRTUAL;
FUNCTION GetClassName: PCHAR; VIRTUAL;
PROCEDURE GetWindowClass(VAR c: TWndClass); VIRTUAL;
PROCEDURE SelectFont(VAR msg: TMessage); VIRTUAL id_first + 101;
PROCEDURE SaveFont(VAR msg: TMessage); VIRTUAL id_first + 103;
PROCEDURE Help(VAR msg: TMessage); VIRTUAL id_first + 102;
PROCEDURE WMPaint(VAR msg: TMessage); VIRTUAL wm_first + wm_Paint;
PROCEDURE FillFontDir(wBytes: WORD);
PROCEDURE WMDestroy(VAR msg: TMessage); VIRTUAL wm_first + wm_Destroy;
END;
VAR
thisApp: TThisApp;
outF: FILE;
FUNCTION HelpDlgProc(win: HWnd; m, w: WORD; l: LONGINT): BOOL; EXPORT;
BEGIN
HelpDlgProc := FALSE;
IF m = wm_InitDialog THEN BEGIN
HelpDlgProc := TRUE;
END ELSE IF m = wm_Command THEN BEGIN
EndDialog(win, 0);
HelpDlgProc := TRUE;
END;
END;
PROCEDURE TFnWin.FillFontDir(wBytes: WORD);
{Fill FontDir structure with info from text metrics and computed FNT size}
BEGIN
WITH fd, tm DO BEGIN
version := 512;
face := wBytes * tmHeight + (tmLastChar - tmFirstChar) * 4 + fntHdSize;
size := face + STRLEN(faceName) + 1;
FillChar(copyright, SIZEOF(copyright), #0);
STRPCOPY(copyright, '(c) of orig. font "' + STRPAS(orgFaceName) + '" applies');
typ := 0;
point := (cf.iPointSize + 5) DIV 10;
vRes := tmDigitizedAspectY;
hRes := tmDigitizedAspectX;
asc := tmAscent;
iLead := tmInternalLeading;
eLead := tmExternalLeading;
ita := tmItalic;
usc := tmUnderlined;
strike := tmStruckOut;
weight := tmWeight;
charset := ANSI_Charset;
h := tmHeight;
pitchAndFam := tmPitchAndFamily AND NOT (TMPF_Vector OR TMPF_TrueType OR TMPF_Device);
IF (pitchAndFam AND TMPF_Fixed_Pitch) <> 0 THEN BEGIN {*not* fixed pitch}
w := 0;
END ELSE BEGIN
w := tmAveCharWidth;
END;
avgW := tmAveCharWidth;
maxW := tmMaxCharWidth;
fCh := tmFirstChar;
lCh := tmLastChar;
dCh := tmDefaultChar - tmFirstChar;
bCh := tmBreakChar - tmFirstChar;
widthBytes := wBytes;
dev := 0;
rsvd := 0;
END;
END;
CONSTRUCTOR TFnWin.Init;
BEGIN
TDlgWindow.Init(NIL, appName);
END;
FUNCTION TFnWin.GetClassName: PCHAR;
VAR
d: PCHAR;
BEGIN
GetClassName := appName;
END;
PROCEDURE TFnWin.GetWindowClass(VAR c: TWndClass);
BEGIN
TDlgWindow.GetWindowClass(c);
{c.hIcon := LoadIcon(hInstance, appName);}
{doesn't work with TDlgWindow!?, do it in SetupWindow }
END;
PROCEDURE TFnWin.SetupWindow;
BEGIN
TDlgWindow.SetupWindow;
SetClassWord(hWindow, GCW_HICON, LoadIcon(hInstance, appName));
GetObject(GetStockObject(System_Font), SIZEOF(TLogFont), @lf);
lf.lfFaceName[31] := #0; {safety}
fnH := CreateFontIndirect(lf);
END;
PROCEDURE TFnWin.WMPaint(VAR msg: TMessage);
VAR
ps: TPaintStruct;
b: HBrush;
pen: HPen;
r: TRect;
w, h, h1: INTEGER;
oldfnH: HFont;
BEGIN
{Paint simulated window title and menu bar}
BeginPaint(hWindow, ps);
GetClientRect(hWindow, r);
w := r.right - r.left - 11;
SetBkMode(ps.hDC, transparent);
oldfnH := SelectObject(ps.hDC, fnH);
GetTextMetrics(ps.hDC, tm);
h := GetSystemMetrics(sm_CYSize);
IF tm.tmHeight > h THEN BEGIN
h := tm.tmHeight - 1;
END;
h1 := GetSystemMetrics(sm_CYSize);
IF (tm.tmHeight + tm.tmExternalLeading) >= h1 THEN BEGIN
h1 := tm.tmHeight + tm.tmExternalLeading + 1;
END;
SetRect(r, 11, 11, w, 11 + h);
b := CreateSolidBrush(GetSysColor(color_ActiveCaption));
FillRect(ps.hDC, r, b);
DeleteObject(b);
pen := SelectObject(ps.hDC, CreatePen(ps_Solid, 1, GetSysColor(color_WindowFrame)));
MoveTo(ps.hDC, 10, 10);
LineTo(ps.hDC, w, 10);
LineTo(ps.hDC, w, 10 + h + 1);
LineTo(ps.hDC, 10, 10 + h + 1);
LineTo(ps.hDC, 10, 10);
MoveTo(ps.hDC, 10, 10 + h + 2);
LineTo(ps.hDC, 10, 10 + h + 2 + h1);
LineTo(ps.hDC, w, 10 + h + 2 + h1);
LineTo(ps.hDC, w, 10 + h + 1);
DeleteObject(SelectObject(ps.hDC, pen));
SetTextColor(ps.hDC, GetSysColor(color_CaptionText));
DrawText(ps.hDC, 'Sample Window Title', -1, r, dt_Center OR dt_VCenter OR dt_SingleLine);
SetRect(r, 11, 10 + h + 2, w, 10 + h + 2 + h1);
b := CreateSolidBrush(GetSysColor(color_Menu));
FillRect(ps.hDC, r, b);
DeleteObject(b);
r.bottom := r.bottom - 1;
SetTextColor(ps.hDC, GetSysColor(color_MenuText));
DrawText(ps.hDC, ' &Sample Menu Bar', -1, r, dt_VCenter OR dt_SingleLine);
SelectObject(ps.hDC, oldfnH);
EndPaint(hWindow, ps);
END;
PROCEDURE TFnWin.Help(VAR msg: TMessage);
VAR
inst: TFarProc;
BEGIN
inst := MakeProcInstance(@HelpDlgProc, hInstance);
DialogBox(hInstance, 'SYSFONH', hWindow, inst);
FreeProcInstance(inst);
END;
PROCEDURE TFnWin.SelectFont(VAR msg: TMessage);
VAR
oldFnH: HFont;
mDC: HDC;
BEGIN
FillChar(cf, SIZEOF(TChooseFont), #0);
WITH cf DO BEGIN
lStructSize := SIZEOF(TChooseFont);
hWndOwner := hWindow;
{nFontType := Screen_FontType;}
lpLogFont := @lF;
flags := CF_ScreenFonts OR CF_InitToLogFontStruct;
END;
{Standard ChooseFont dialog}
IF ChooseFont(cf) THEN BEGIN
{Create a memory device context}
dc := GetDC(hWindow);
mDC := CreateCompatibleDC(dc);
ReleaseDC(hWindow, dc);
{Create and select chosen font, get text metrics info}
DeleteObject(fnH);
fnH := CreateFontIndirect(lf);
lf.lfFaceName[31] := #0; {safety}
InvalidateRect(hWindow, NIL, TRUE);
oldFnH := SelectObject(mDC, fnH);
GetTextMetrics(mDC, tm);
IF lf.lfCharset <> ANSI_CharSet THEN BEGIN
MessageBeep(mb_IconExclamation);
MessageBox(0, 'Character set is not ANSI', lf.lfFaceName, mb_OK OR mb_IconExclamation);
END;
IF (tm.tmFirstChar > 32) OR (tm.tmLastChar < 255) THEN BEGIN
MessageBeep(mb_IconExclamation);
MessageBox(0, 'Font doesn''t contain all characters from 0x20 to 0xFF',
lf.lfFaceName, mb_OK OR mb_IconExclamation);
END;
{Cleanup}
SelectObject(mDC, oldFnH);
DeleteDC(mDC);
END;
END;
PROCEDURE TFnWin.SaveFont(VAR msg: TMessage);
VAR
wBytes: WORD;
oldFnH: HFont;
off, w, h, ix, ix1, ix2: WORD;
mDC, mDC1: HDC;
bmH, bmH1: HBitmap;
raster: ARRAY[0..511] OF BYTE;
st: ARRAY[0..1] OF CHAR;
s1, s2, s3: STRING[8];
rasterOff: WORD;
fnTab: ARRAY[0..255] OF RECORD width, off: WORD END;
dirName, fileName, fileTitle, filter: ARRAY[0..255] OF CHAR;
defExt: ARRAY[0..3] OF CHAR;
hdrBuf: HdrBufR;
textExt: LONGINT;
rH, mH: THandle;
mP: ^CHAR;
BEGIN
{Save as... Dialog}
FillChar(ofn, SIZEOF(TOpenFileName), #0);
GetSystemDirectory(dirName, SIZEOF(dirName));
fileName[0] := #0;
STRCOPY(filter, 'Font File(*.FON);*.FON');
STRCOPY(defExt, 'FON');
filter[16] := #0;
filter[23] := #0;
WITH ofn DO BEGIN
lStructSize := SIZEOF(TOpenFileName);
hWndOwner := hWindow;
lpstrFilter := filter;
lpstrFile := fileName;
nMaxFile := SIZEOF(fileName);
lpstrFileTitle := fileTitle;
nMaxFileTitle := SIZEOF(fileTitle);
lpstrInitialDir := dirName;
flags := ofn_OverwritePrompt OR ofn_NoChangeDir OR ofn_pathMustExist;
lpstrDefExt := defExt;
lpstrTitle := 'Save generated system font as';
END;
IF GetSaveFileName(ofn) THEN BEGIN
{Create a memory device context}
dc := GetDC(hWindow);
mDC := CreateCompatibleDC(dc);
ReleaseDC(hWindow, dc);
{Create a monochrome 256x256 bitmap}
bmH := CreateBitmap(256, 256, 1, 1, NIL);
{Make the memory DC's area 256x256}
SelectObject(mDC, bmH);
{Select chosen font into the memory DC, get text metrics}
oldFnH := SelectObject(mDC, fnH);
GetTextMetrics(mDC, tm);
{Create another memory DC}
mDC1 := CreateCompatibleDC(mDC);
{Create a monochrome 8x256 bitmap}
bmH1 := CreateBitmap(8, 256, 1, 1, NIL);
{Make the memory DC's area 8x256}
SelectObject(mDC1, bmH1);
{offset of raster pattern part in FNT resource}
rasterOff := fntHdSize + 4 * (tm.tmLastChar - tm.tmFirstChar);
off := rasterOff;
{Compute width and offset of each character pattern}
wBytes := 1;
st[1] := #0;
h := tm.tmHeight;
FOR ix := ORD(tm.tmFirstChar) TO ORD(tm.tmLastChar) DO BEGIN
{For each font character:}
st[0] := CHR(ix);
{Get width and height in pixels}
textExt := GetTextExtent(mDC, st, 1);
fnTab[ix].width := LoWord(textExt);
fnTab[ix].off := off;
w := (LoWord(textExt) + 7) DIV 8;
wBytes := wBytes + w;
off := off + w * h;
END; {FOR ix}
IF (LONGINT(wBytes) * h) > 64350 THEN BEGIN
MessageBeep(mb_IconExclamation);
MessageBox(0, 'Font resource too big (> 65535 bytes)', lf.lfFaceName,
mb_OK OR mb_IconExclamation);
END ELSE BEGIN
{If original font generated by SysFon, remove the 'SysFon: ' string}
IF STRLCOMP(lf.lfFaceName, 'SysFon: ', 8) = 0 THEN BEGIN
STRCOPY(orgFaceName, ADDR(lf.lfFaceName[8]));
END ELSE BEGIN
STRCOPY(orgFaceName, lf.lfFaceName);
END;
{Construct new face name}
FillChar(faceName, SIZEOF(faceName), #0);
STRCOPY(faceName, 'SysFon: ');
STRLCAT(faceName, orgFaceName, lf_FaceSize - 1);
{Fill FontDir structure from text metrics and computed size (wBytes)}
FillFontDir(wBytes);
{Use filter as null buffer}
FillChar(filter, SIZEOF(filter), #0);
{retrieve .FON header from resource #12345}
rH := FindResource(hInstance, MakeIntResource(12345), MakeIntResource(12345));
mH := LoadResource(hInstance, rH);
mP := LockResource(mH);
MOVE(mP^, hdrBuf, fonHdSize);
UnlockResource(mH);
FreeResource(mH);
{Fill variable part of .FON header}
hdrBuf.fntSize := (fd.size + 15) DIV 16;
STR(100 * fd.hRes DIV fd.vRes, s1);
STR(fd.hRes, s2);
STR(fd.vRes, s3);
STRPCOPY(hdrBuf.moduleDescription, 'FONTRES ' + s1 + ',' + s2 + ',' +
s3 + ': System Font (' + STRPAS(orgFaceName) + ')');
hdrBuf.moduleDescriptionLen := STRLEN(hdrBuf.moduleDescription);
{Write .FON header}
IF IORESULT = 0 THEN BEGIN END; {Clear I/O error flag}
ASSIGN(outF, fileName);
REWRITE(outF, 1);
BLOCKWRITE(outF, hdrBuf, fonHdSize);
{Write FONTDIR resource}
BLOCKWRITE(outF, fd, SIZEOF(FontDirEntry));
BLOCKWRITE(outF, filter, 1); {null device name}
BLOCKWRITE(outF, faceName, STRLEN(faceName) + 1);
BLOCKWRITE(outF, filter, 41 - STRLEN(faceName));
{Write FNT resource}
BLOCKWRITE(outF, fd, SIZEOF(FontDirEntry));
{Write offset to raster patterns}
BLOCKWRITE(outF, rasterOff, 2);
{Write 3 null bytes (meaning unknown)}
BLOCKWRITE(outF, filter, 3);
{Write the width/offset table}
BLOCKWRITE(outF, fnTab[tm.tmFirstChar], 4 * (tm.tmLastChar - tm.tmFirstChar + 1));
{Extra char at end}
w := 8;
BLOCKWRITE(outF, w, 2);
BLOCKWRITE(outF, off, 2);
FOR ix := ORD(tm.tmFirstChar) TO ORD(tm.tmLastChar) DO BEGIN
st[0] := CHR(ix);
w := fnTab[ix].width;
off := (w + 7) DIV 8;
{Clear background to 8 pixel boundary}
PatBlt(mDC, 0, 0, off * 8, h, Whiteness);
{Write the character}
TextOut(mDC, 0, 0, st, 1);
{mDC now contains the pixel representation of the character}
w := 0;
FOR ix1 := 1 TO off DO BEGIN
{Get next 8-pixel column of raster pattern}
BitBlt(mDC1, 0, 0, 8, h, mDC, w, 0, NotSrcCopy);
{Bitmaps are always padded to multiples of 16 bit}
GetBitmapBits(bmH1, h*2, @raster);
FOR ix2 := 1 TO h - 1 DO BEGIN
raster[ix2] := raster[2*ix2];
END;
BLOCKWRITE(outF, raster, h);
w := w + 8;
END;
END;
{Extra char at end}
BLOCKWRITE(outF, filter, h);
{Face Name}
BLOCKWRITE(outF, faceName, STRLEN(faceName) + 1);
{Trailer}
BLOCKWRITE(outF, filter, hdrBuf.fntSize * 16 - fd.size);
CLOSE(outF);
IF IORESULT <> 0 THEN BEGIN
MessageBeep(mb_IconExclamation);
MessageBox(0, 'Save failed', fileName, mb_OK OR mb_IconExclamation);
END ELSE BEGIN
{MessageBeep(mb_IconQuestion);}
IF MessageBox(0, 'Font saved. Update system settings? ' + #13 + #10 +
'(You must restart Windows for changes to take effect.)',
filename, mb_YesNo OR mb_IconQuestion) = idYes THEN BEGIN
{Update SYSTEM.INI}
GetWindowsDirectory(filter, SIZEOF(filter));
IF filter[STRLEN(filter)-1] <> '\' THEN BEGIN
STRCAT(filter, '\');
END;
STRCAT(filter, 'SYSTEM.INI');
{Use full path name if not saved in the windows system directory}
IF STRLCOMP(fileName, dirName, STRLEN(dirName)) = 0 THEN BEGIN
WritePrivateProfileString('boot', 'fonts.fon', fileTitle, filter);
END ELSE BEGIN
WritePrivateProfileString('boot', 'fonts.fon', fileName, filter);
END;
END; {idYes}
END; {IOResult = 0}
END; {not too big}
{Cleanup}
SelectObject(mDC, oldFnH);
DeleteDC(mDC);
DeleteObject(bmH);
DeleteDC(mDC1);
DeleteObject(bmH1);
END; {IF GetSaveFileName}
END; {SaveFont}
PROCEDURE TFnWin.WMDestroy(VAR msg: TMessage);
BEGIN
DeleteObject(fnH);
TDlgWindow.WMDestroy(msg);
END;
PROCEDURE TThisApp.InitMainWindow;
BEGIN
mainWindow := NEW(pFnWin, Init);
END;
BEGIN
thisApp.Init(appName);
thisApp.Run;
thisApp.Done;
END.